;For compiler, speedup hacks.

(declare (mapex t)
         (special **exp** **beta** **vals** **unevlis** **evlis** **pc** **clink**
                  **fun** **val** **tem** **fluid!vars** **fluid!vals**
                  **queue** **tick** **quantum** **process** **procnum**
                  version lispversion))

(defun version macro (x)
       (cond (compiler-state (list 'quote (status uread)))
	     (t (rplaca x 'quote)
		(rplacd x (list version))
		(list 'quote version))))

(declare (read))

(setq version ((lambda (compiler-state) (version)) t))

(defun fastcall (atsym)
       (cond ((eq (car (cdr atsym)) 'subr)
	      (subrcall nil (cadr (cdr atsym))))
	     (t ((lambda (subr)
			 (cond (subr (remprop atsym 'subr)
				     (putprop atsym
					      subr
					      'subr)
				     (subrcall nil subr))
			       (t (apply atsym nil))))
		 (get atsym 'subr)))))

(defun push macro (l) (list 'setq '**clink** (push1 (cdr l))))

(declare (eval (read)))

(defun push1 (x)
       (cond ((null x) '**clink**)
             (t (list 'cons (car x) (push1 (cdr x))))))

(defun top macro (l)
   (list 
     (list 'lambda '(ltem)
       (cons 'setq
             (mapcan '(lambda (x)
                        (list x '(car ltem)  'ltem '(cdr ltem) ))
                     (cdr l))))
     '**clink**))

(defun pop macro (l)
 (list 'setq '**clink**
   (list 
     (list 'lambda '(ltem)
       (cons 'setq
             (mapcan '(lambda (x)
                        (list x '(car ltem)  'ltem '(cdr ltem) ))
                     (cdr l))))
     '**clink**)))

(defun primop macro (x) (list 'getl (cadr x) ''(subr expr lsubr))))

(defun betacons (lamb obeta ovals name)
       (cons 'beta
             (cons (reverse (cadr lamb))
                   (cons (cons obeta ovals)
                         (cons (caddr lamb) name)))))

(defun bind (newvars newvals name)
       (setq **beta** (cons name
                            (cons newvars
                                  (cons (cons **beta** **vals**)
                                        nil)))
             **vals** newvals))

(defun vars macro (l) (list 'cadr (cadr l)))

(defun obeta macro (l) (list 'caaddr (cadr l)))

(defun ovals macro (l) (list 'cdaddr (cadr l)))

(defun body macro (l) (list 'cadddr (cadr l)))

(defun name macro (l) (list 'cddddr (cadr l)))

(defun lookup (identifier beta vals)
       (prog (vars)
        nextbeta
           (setq vars (vars beta))
        nextvar
           (cond ((null vars)
                  (setq vals (ovals beta))
                  (cond ((setq beta (obeta beta)) (go nextbeta))
                        (t (return nil))))
                 ((eq identifier (car vars)) (return vals))
                 (t (setq vars (cdr vars)
                          vals (cdr vals))
                    (go nextvar)))))

;Basic interpreter -- initialization, main-loop, time slicing.

(defun scheme ()
       (setq version (version)  lispversion (status lispversion))
       (terpri)
       (princ '|This is SCHEME |)
       (princ version)
       (princ '| running in LISP |)
       (princ lispversion)
       (setq **beta** nil  **vals** nil  **fluid!vars** nil  **fluid!vals** nil
	     **queue** nil
             **process** (create!process '(**top** '|SCHEME -- Toplevel| '|==> |)))
       (swapinprocess)
       (alarmclock 'runtime **quantum**)
       (mloop))

(setq **top**
      '(lambda (**message** **prompt**)
               (labels ((**top1**
                          (lambda (**ignore1** **ignore2** **ignore3**)
                             (**top1** (terpri) (princ **prompt**)
                                       (print (set '* (evaluate (read))))))))
                    (**top1** (terpri) (princ **message**) nil))))

(defun mloop ()
       (do ((**tick** nil))  (nil)
          (and **tick** (allow) (schedule))
          (fastcall **pc**)))



(defun allow ()
  ((lambda (vcell)
       (cond (vcell (car vcell))
             (t t)))
   (lookup '*allow* **beta** **vals**)))

(defun schedule ()
       (cond (**queue**
	      (swapoutprocess)
	      (nconc **queue** (list **process**))
	      (setq **process** (car **queue**)
		    **queue** (cdr **queue**))
	      (swapinprocess)))
       (setq **tick** nil)
       (alarmclock 'runtime **quantum**))

(defun swapoutprocess ()
       (putprop **process**
                (list **exp** **beta** **vals** **evlis** **unevlis** **pc** **clink**
                      **fluid!vars** **fluid!vals** **val** **tem**)
                '**process**))

(defun swapinprocess () 
       (mapc 'set
             '(**exp** **beta** **vals** **evlis** **unevlis** **pc** **clink**
               **fluid!vars** **fluid!vals** **val** **tem**)
             (get **process** '**process**) ))

(defun settick (x) (setq **tick** t))
(setq **quantum** 1000000. alarmclock 'settick)

;Central evaluator functions.

(defun dispatch ()
       (cond ((atom **exp**)
              (cond ((numberp **exp**) (setq **val** **exp**))
                    ((setq **val** (primop **exp**)))
                    ((setq **tem** (lookup **exp** **beta** **vals**))
                     (setq **val** (car **tem**)))
                    (t (setq **val** (symeval **exp**)))))
             ((atom (car **exp**))
              (cond ((setq **tem** (get (car **exp**) 'aint))
                     (fastcall **tem**))
                    ((setq **tem** (get (car **exp**) 'amacro))
                     (setq **exp** (funcall **tem** **exp**))
                     (dispatch))
                    ((eq (car **exp**) 'lambda)
                     (setq **val** (betacons **exp** **beta** **vals** **exp**)))
                    (t (push **exp** **beta** **vals** **pc**)
                       (setq **exp** (car **exp**)  **pc** 'gotfun)
                       (dispatch))))
             (t (push **exp** **beta** **vals** **pc**)
                (setq **exp** (car **exp**)  **pc** 'gotfun)
                (dispatch))))

(defun gotfun ()
       (pop **exp**)
       (push **val**)			;stack = fun,beta,vals,pc.
       (setq **unevlis** (cdr **exp**)
             **evlis** nil)
       (evlis))

(defun evlis ()
       (cond ((null **unevlis**)
              (pop **fun** **beta** **vals** **pc**)
              (cond ((eq (car **fun**) 'subr)
                     (setq **val** (revsubrapply **fun** **evlis**)))
		    ((eq (car **fun**) 'lsubr)
		     (setq **val** (revlsubrapply **fun** **evlis**)))
		    ((eq (car **fun**) 'expr)
		     (setq **val** (revapply (cadr **fun**) **evlis**)))
                    ((eq (car **fun**) 'beta)
                     (setq **exp** (body **fun**)
                           **beta** **fun**
                           **vals** **evlis**)
                     (dispatch))
                    ((eq (car **fun**) 'lambda)
                     (setq **beta** (betacons **fun** **beta** **vals** **fun**)
                           **exp** (body **beta**)
                           **vals** **evlis**)
                     (dispatch))
                    ((eq (car **fun**) 'delta)
                     (setq **clink** (cadr **fun**))
                     (pop **beta** **vals** **fluid!vars** **fluid!vals** **pc**))
                    (t (error '|Bad Function - Evlis| **fun** 'fail-act))))
             (t (top **fun** **beta** **vals**)
                (push **evlis** **unevlis**) 
                (setq **exp** (car **unevlis**) **pc** 'evlis1)
                (dispatch))))

(defun evlis1 ()
      (pop **evlis** **unevlis**)
      (setq **evlis** (cons **val** **evlis**)  **unevlis** (cdr **unevlis**))
      (evlis))

(defun revapply (fn vals)
       (prog (a b c d e)
	     (or vals (return (funcall fn)))
	     (setq a (car vals) vals (cdr vals))
	     (or vals (return (funcall fn a)))
	     (setq b (car vals) vals (cdr vals))
	     (or vals (return (funcall fn b a)))
	     (setq c (car vals) vals (cdr vals))
	     (or vals (return (funcall fn c b a)))
	     (setq d (car vals) vals (cdr vals))
	     (or vals (return (funcall fn d c b a)))
	     (setq e (car vals) vals (cdr vals))
	     (or vals (return (funcall fn e d c b a)))
	     (return (apply fn (reverse vals)))))

(defun revsubrapply (fn vals)
       (prog (a b c d e)
	     (or vals (return (subrcall nil (cadr fn))))
	     (setq a (car vals) vals (cdr vals))
	     (or vals (return (subrcall nil (cadr fn) a)))
	     (setq b (car vals) vals (cdr vals))
	     (or vals (return (subrcall nil (cadr fn) b a)))
	     (setq c (car vals) vals (cdr vals))
	     (or vals (return (subrcall nil (cadr fn) c b a)))
	     (setq d (car vals) vals (cdr vals))
	     (or vals (return (subrcall nil (cadr fn) d c b a)))
	     (setq e (car vals) vals (cdr vals))
	     (or vals (return (subrcall nil (cadr fn) e d c b a)))
	     (error '|Too Many Arguments to a Subr| (cons fn vals) 'wrng-no-args)))

(defun revlsubrapply (fn vals)
       (prog (a b c d e)
	     (or vals (return (lsubrcall nil (cadr fn))))
	     (setq a (car vals) vals (cdr vals))
	     (or vals (return (lsubrcall nil (cadr fn) a)))
	     (setq b (car vals) vals (cdr vals))
	     (or vals (return (lsubrcall nil (cadr fn) b a)))
	     (setq c (car vals) vals (cdr vals))
	     (or vals (return (lsubrcall nil (cadr fn) c b a)))
	     (setq d (car vals) vals (cdr vals))
	     (or vals (return (lsubrcall nil (cadr fn) d c b a)))
	     (setq e (car vals) vals (cdr vals))
	     (or vals (return (lsubrcall nil (cadr fn) e d c b a)))
	     (setplist 'the-lsubr-apply-atom fn)
	     (apply 'the-lsubr-apply-atom (reverse vals))))

;Basic AINTs.

(defprop evaluate aeval aint)

(defun aeval ()
       (push **beta** **vals** **pc**)
       (setq **exp** (cadr **exp**)  **pc** 'aeval1)
       (dispatch))

(defun aeval1 ()
       (pop **beta** **vals** **pc**)
       (setq **exp** **val**)
       (dispatch))


(defprop if aif aint)

(defun aif ()
       (push **exp** **beta** **vals** **pc**)
       (setq **exp** (cadr **exp**)  **pc** 'if1)
       (dispatch))

(defun if1 ()
       (pop **exp** **beta** **vals** **pc**)
       (setq **exp** (cond (**val** (caddr **exp**)) (t (cadddr **exp**))))
       (dispatch))


(defprop test atest aint)

(defun atest ()
       (push **exp** **beta** **vals** **pc**)
       (setq **exp** (cadr **exp**)  **pc** 'test1)
       (dispatch))

(defun test1 ()
       (cond (**val**
              (pop **exp**)
              (top **beta** **vals**)
              (push **val**)
	      (setq **exp** (caddr **exp**) **pc** 'test2)
	      (dispatch))
	     (t (pop **exp** **beta** **vals** **pc**)
                (setq **exp** (cadddr **exp**))
                (dispatch))))

(defun test2 ()
       (pop **tem**)
       (push **val**)
       (setq **evlis** (list **tem**) **unevlis** nil)
       (evlis))

(defprop quote aquote aint)

(defun aquote () (setq **val** (cadr **exp**)))


(defprop labels alabels aint)

(defun alabels ()
       (bind (mapcar 'car (cadr **exp**))
             (mapcar 'car (cadr **exp**))
             'labels)
       (map '(lambda (defl vall)
		     (rplaca vall
			     (betacons (cadar defl)
				       **beta**
				       **vals**
				       (caar defl))))
	    (cadr **exp**)
	    **vals**)
       (setq **exp** (caddr **exp**))
       (dispatch))


;Side effects.

(defprop define adefine aint)

(defun adefine () (setq **val** (eval **exp**)))

(defun define fexpr (l)
       (set (car l) (betacons (cadr l) nil nil (car l)))
       (putprop (car l) (cadr l) 'schemefun)
       (car l))


(defun aset (var val)
       ((lambda (vc)
                (cond (vc (rplaca vc val))
                      (t (set var val))))
        (lookup var **beta** **vals**)))

;Fluid variable stuff.

(defprop fluid!bind afluidbind aint)

(defun afluidbind ()
       (saveup)
       (setq **beta** **beta**
	     **vals** **vals**
	     **unevlis** (cadr **exp**)
	     **evlis** **fluid!vals**)
       (push **exp**)
       (afluidbind1))

(defun afluidbind1 ()
       (cond ((null **unevlis**)
	      (pop **exp**)
	      (setq **tem**
		    (do ((z (cadr **exp**) (cdr z))
			 (y **fluid!vars** (cons (caar z) y)))
			((null z) y)))
	      (setq **unevlis** **fluid!vals**
		    **fluid!vals** **evlis**
		    **evlis** **fluid!vars**
		    **fluid!vars** **tem**
		    **exp** (caddr **exp**)
		    **pc** 'unbind)
	      (dispatch))
	     (t (setq **exp** (cadar **unevlis**)
		      **beta** **beta**
		      **vals** **vals**
		      **pc** 'afluidbind2)
		(dispatch))))

(defun afluidbind2 ()
       (setq **evlis** (cons **val** **evlis**)
	     **unevlis** (cdr **unevlis**)
	     **pc** 'afluidbind1))

(defun unbind ()
       (setq **fluid!vars** **evlis**)
       (setq **fluid!vals** **unevlis**)
       (restore))

(defprop fluid!value afluidval aint)

(defun afluidval ()
       (setq **val**
	     ((lambda (vc)
		      (cond (vc (car vc))
			    (t (symeval (cadr **exp**)))))
	      (fluid!lookup (cadr **exp**) **fluid!vars** **fluid!vals**))))


(defun fluid!set (var val)
       ((lambda (vc)
                (cond (vc (rplaca (cdr vc) val))
                      (t (set var val))))
        (fluid!lookup var **fluid!vars** **fluid!vals**)))

(defun fluid!lookup (id vars vals)
       (prog ()
         lp (cond ((null vars) (return nil))
                  ((eq id (car vars))
                   (cond ((null vals) (error '|Vals too short -- fluid!lookup| id 'fail-act)))
                   (return vals))
                  ((null vals) (error '|Too few vals - fluid!lookup| id 'fail-act)))
            (setq vars (cdr vars)  vals (cdr vals))
            (go lp)))

;Hairy control structure.

(setq **procnum** 0)

(defun genprocname ()
       ((lambda (base *nopoint)
		(implode (append '(p r o c e s s)
				  (exploden (setq **procnum** (1+ **procnum**))))))
	10. t))

(defun create!process (exp)
       ((lambda (**process** **beta** **vals** **evlis** **unevlis** **pc** **clink**
                 **exp** **fluid!vars** **fluid!vals** **val** **tem**)
                (dispatch)
                (swapoutprocess)
                **process**)
        (genprocname) **beta** **vals** nil nil 'terminate nil
        exp **fluid!vars** **fluid!vals** nil nil))

(defun start!process (p)
       (cond ((or (not (atom p)) (not (get p '**process**)))
	      (error '|Bad Process - START!PROCESS| p 'fail-act)))
       (or (eq p **process**) (memq p **queue**)
	   (setq **queue** (nconc **queue** (list p))))
       p)

(defun stop!process (p)
       (cond ((memq p **queue**)
	      (setq **queue** (delete p **queue**))
	      p)
	     ((eq p **process**)
	      (setq **val** p)
	      (terminate))))

(defun terminate ()
       (swapoutprocess)
       (cond ((null **queue**)
	      (setq **beta** nil  **vals** nil  **fluid!vars** nil  **fluid!vals** nil)
	      (setq **process**
		    (create!process '(**top** '|SCHEME -- Queueout| '|==> |))))
	     (t (setq **process** (car **queue**)
		      **queue** (cdr **queue**))))
       (swapinprocess)
       **val**)


(defprop evaluate!uninterruptibly evun aint)

(defun evun ()
       (bind (list '*allow*) (list nil) 'evaluate!unterruptibly)
       (setq **exp** (cadr **exp**))
       (dispatch))


(defprop catch acatch aint)

(defun acatch ()
       (bind (list (cadr **exp**))
             (list (list 'delta
                         ((lambda (**clink**)
                           (push **beta** **vals** **fluid!vars** **fluid!vals** **pc**)
                           **clink**)
                          **clink**)
			 (cadr **exp**)))
             'catch)
       (setq **exp** (caddr **exp**))
       (dispatch))

(defun schbt ()
       (do ((prinlevel 3)
	    (prinlength 6)
	    (z **clink**
	       (cond ((and z
			   (or (atom (car z))
			       (memq (caar z)
				     '(lambda beta delta fluid!bind))))
		      (schbtprint (car z))
		      (cdr z))
		     (t (cdr (cddddr z))))))
	   ((null z))))

(defun schbtprint (x)
	(cond ((atom x) (print x))
	      ((eq (car x) 'beta)
	       (cond ((name x)
		      (print (name x)))
		     (t (print x))))
	      ((eq (car x) 'delta)
	       (print 'catchtag)
	       (prin1 (car (cddddr x))))
	      (t (print x))))

ββββ